PC go! 2008 April/PCgo 2008-04 (DVD).iso/interface/contents/demoversionen_3846/13664/files/Data1.cab/ctltcviewer.ctl

Text File | 2001-10-16 | 5.6 KB | 242 lines

VERSION 5.00
Begin VB.UserControl ctlTcViewer
   BorderStyle     =   1  'Fixed Single
   ClientHeight    =   4320
   ClientLeft      =   0
   ClientTop       =   0
   ClientWidth     =   4710
   ControlContainer=   -1  'True
   KeyPreview      =   -1  'True
   ScaleHeight     =   288
   ScaleMode       =   3  'Pixel
   ScaleWidth      =   314
End
Attribute VB_Name = "ctlTcViewer"
Attribute VB_GlobalNameSpace = False
Attribute VB_Creatable = True
Attribute VB_PredeclaredId = False
Attribute VB_Exposed = True
'******************************************************************'
'*                                                                *'
'*                      TurboCAD for Windows                      *'
'*                   Copyright (c) 1993 - 2001                    *'
'*             International Microcomputer Software, Inc.         *'
'*                            (IMSI)                              *'
'*                      All rights reserved.                      *'
'*                                                                *'
'******************************************************************'

Option Explicit

Public Event ClickGraphic(gxGr As Graphic, dist As Double)

Dim gxDwg As Drawing
Dim gxVw  As View
Dim bAttached As Boolean
Dim dblAperture As Double
Dim bUpdate As Boolean

Public Sub Refresh()
    Cls
    If (bAttached) Then
        If (bUpdate) Then
            gxVw.Refresh
        End If
    End If
End Sub

Public Sub Scroll(dy As Long, dx As Long)
    If (bAttached) Then
        On Error GoTo VwZoom
         gxVw.Camera.Slide gxVw.ViewHeight() * dy / 10, gxVw.ViewWidth() * dx / 10
        Exit Sub
VwZoom:
        Dim yTop As Double
        Dim xLeft As Double

        On Error GoTo Err

        xLeft = gxVw.ViewLeft + gxVw.ViewWidth() * dx / 10
        yTop = gxVw.ViewTop - gxVw.ViewHeight() * dy / 10

        gxVw.Update = False

        gxVw.ViewLeft = xLeft
        gxVw.ViewTop = yTop

    End If
Err:
End Sub

Public Sub Zoom(factor As Double)

    If (bAttached) Then
        If (factor <> 0) Then
            On Error GoTo VwZoom
            gxVw.Camera.Zoom factor
            Exit Sub

        Else
            gxVw.ZoomToExtents
        End If
    End If
    Exit Sub
VwZoom:
        Dim xC As Double
        Dim yC As Double

        Dim w As Double
        Dim h As Double

        On Error GoTo Err
        w = gxVw.ViewWidth
        h = gxVw.ViewHeight

        xC = gxVw.ViewLeft + w / 2
        yC = gxVw.ViewTop - h / 2

        w = w * factor
        h = h * factor

        gxVw.Update = False

        gxVw.ViewLeft = xC - w / 2
        gxVw.ViewTop = yC + h / 2

        gxVw.ViewWidth = w
        gxVw.ViewHeight = h
Err:
End Sub

Public Function Detach() As Boolean

    On Error Resume Next
    If (Not gxVw Is Nothing) Then
        gxVw.Delete
        Set gxVw = Nothing
    End If

    If (Not gxDwg Is Nothing) Then
        Set gxDwg = Nothing
    End If
    bAttached = False

    Detach = bAttached

End Function
Public Function Attach(objDwg As Object) As Boolean

    Dim gxProps As Properties
    Dim gxProp As Property

    On Error GoTo Err

    Detach

    Set gxDwg = objDwg
    Set gxProps = gxDwg.Application.Properties
    Set gxProp = gxProps("Aperture")

    dblAperture = gxProp

    Set gxProp = Nothing
    Set gxProps = Nothing

    Set gxVw = gxDwg.Views.Add(hWnd)
    gxVw.ZoomToExtents

    bAttached = True

Err:
    If (Err <> 0) Then
        MsgBox Err.Description
    End If

    Attach = bAttached
End Function

Private Sub UserControl_Initialize()
    bAttached = False
    bUpdate = True
    Set gxVw = Nothing
    Set gxDwg = Nothing
    dblAperture = 1
End Sub

Private Sub UserControl_MouseUp(Button As Integer, Shift As Integer, X As Single, Y As Single)

    Dim xVw As Double
    Dim yVw As Double
    Dim xW As Double
    Dim yW As Double
    Dim zW As Double

    Dim gxPickRes As PickResult
    Dim gxPickEntry As PickEntry
    Dim cnt As Long
    Dim ind As Long

    If (bAttached) Then

        gxVw.ScreenToView X, Y, xVw, yVw

        Set gxPickRes = gxVw.PickPoint(xVw, yVw, dblAperture, True, True, True, True, True, False)

        cnt = gxPickRes.Count - 1
        For ind = 0 To cnt
            Set gxPickEntry = gxPickRes.Item(ind)
            RaiseEvent ClickGraphic(gxPickEntry.Graphic, gxPickEntry.Distance)
        Next ind

    End If

    Set gxPickEntry = Nothing
    Set gxPickRes = Nothing

    Refresh
End Sub

Private Sub UserControl_Paint()
    If (bAttached And bUpdate) Then
        On Error Resume Next
        gxVw.Refresh
    End If
End Sub

Private Sub UserControl_Terminate()

    Detach

End Sub

Public Property Get ViewSpace() As Variant
    If (Not gxVw Is Nothing) Then
        ViewSpace = gxVw.SpaceMode
    End If
End Property

Public Property Let ViewSpace(ByVal vNewValue As Variant)
    Dim bSpace As ImsiSpaceModeType
    bSpace = vNewValue
    If (Not gxVw Is Nothing) Then
        gxVw.SpaceMode = bSpace
        gxVw.Refresh
    End If
End Property

Public Property Get Aperture() As Variant
    Aperture = dblAperture
End Property

Public Property Let Aperture(ByVal vNewValue As Variant)
    dblAperture = vNewValue
End Property

Public Property Get Update() As Variant
    Update = bUpdate
End Property

Public Property Let Update(ByVal vNewValue As Variant)
    bUpdate = vNewValue
End Property